Sub CreateReadDoc()
    Dim originalDoc As Document
    Dim newDoc As Document
    Dim savePath As String
    Dim originalFolderPath As String
    Dim originalFilePath As String
    
    ' Disable screen updating for faster execution
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Save the document
    ActiveDocument.SaveAs2

    ' Assign the original document to a variable
    Set originalDoc = ActiveDocument
    
    ' Extract the folder path from the original document's file path
    originalFolderPath = Left(originalDoc.FullName, InStrRev(originalDoc.FullName, Application.PathSeparator))
    originalFilePath = originalDoc.FullName
    
    ' Set the save path for the modified document in the same folder as the original document
    savePath = originalFolderPath & "READ_" & originalDoc.Name
    
    ' Create a duplicate of the original document
    originalDoc.SaveAs2 Filename:=savePath, FileFormat:=wdFormatXMLDocument
    Set newDoc = Documents.Open(savePath)
    
    ' Call the InvisibilityOn method to perform the transformations
    Call InvisibilityOn(newDoc)
    
    ' Reopen the original document using its file path
    Documents.Open originalFilePath
    
    ' Save and close the modified document without prompts
    newDoc.Close SaveChanges:=wdSaveChanges
    
    ' Enable screen updating and alerts
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    ' Inform the user about the completion
    MsgBox "Read version created and saved as " & savePath
End Sub

Sub InvisibilityOn(targetDoc As Document)
    Dim i As Long

    ' Move the cursor to the beginning of the document
    targetDoc.Content.Select
    Selection.HomeKey Unit:=wdStory

    ' Delete all text with the color RGB(85, 85, 85)
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Text = ""
        .Font.Color = RGB(85, 85, 85)
        .Replacement.ClearFormatting
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
    End With

    ' Replace all paragraph marks with highlighted and bolded paragraph marks
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^p"
        .Replacement.Text = "^p"
        .Replacement.Style = "Underline"
        .Replacement.Highlight = True
        .Replacement.Font.Bold = True
        .MatchWildcards = False
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Normal" text
    With targetDoc.Content.Find
        .ClearFormatting
        .Style = "Normal"
        .Highlight = False
        .Font.Bold = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Undertag" text
    With Selection.Find
        .ClearFormatting
        .Style = "Undertag"
        .Highlight = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Underline" text
    With targetDoc.Content.Find
        .ClearFormatting
        .Style = "Underline"
        .Highlight = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Emphasis" text
    With targetDoc.Content.Find
        .ClearFormatting
        .Style = "Emphasis"
        .Highlight = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove extra spaces between paragraph marks
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^p ^p"
        .Replacement.Text = ""
        .Replacement.Highlight = False
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove consecutive spaces in non-highlighted text
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "( ){2,}"
        .Font.Bold = False
        .Highlight = False
        .MatchWildcards = True
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove spaces at the beginning of paragraphs
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^p "
        .Replacement.Text = "^p"
        .MatchWildcards = False
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove consecutive paragraph marks in non-highlighted text
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^13{1,}"
        .Replacement.Text = "^p"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove line breaks surrounded on both sides by highlighted text
    Dim para As Paragraph
    Dim rng As Range
    Dim highlighted As Boolean

    For Each para In targetDoc.Paragraphs
        Set rng = para.Range
        rng.MoveEnd wdCharacter, -1 ' Ignore the paragraph mark

        ' Check if the current paragraph contains highlighted text
        highlighted = False
        For i = 1 To rng.Characters.count
            If rng.Characters(i).HighlightColorIndex <> wdNoHighlight Then
                highlighted = True
                Exit For
            End If
        Next i

        ' Check if the next paragraph exists and contains highlighted text
        Dim nextHighlighted As Boolean
        nextHighlighted = False
        If Not para.Next Is Nothing Then
            For i = 1 To para.Next.Range.Characters.count - 1 ' Ignore the paragraph mark
                If para.Next.Range.Characters(i).HighlightColorIndex <> wdNoHighlight Then
                    nextHighlighted = True
                    Exit For
                End If
            Next i
        End If

        ' If both paragraphs contain highlighted text, join them
        If highlighted And nextHighlighted Then
            rng.InsertAfter " " ' Insert a space after the current paragraph
            para.Range.Characters.Last.Delete ' Delete the paragraph mark
        End If
    Next para

    ' Clean up and suppress errors
    targetDoc.Content.Find.ClearFormatting
    targetDoc.Content.Find.MatchWildcards = False
    targetDoc.Content.Find.Replacement.ClearFormatting
    targetDoc.ShowGrammaticalErrors = False
    targetDoc.ShowSpellingErrors = False
End Sub